perm filename COMSUB.SAI[3,ALS] blob
sn#201658 filedate 1971-06-08 generic text, type T, neo UTF8
00100 ENTRY ARRMAK;
00200 BEGIN "COMSUB"
00300
00350 DEFINE ⊃="COMMENT";
00400 REQUIRE "PROLOG.HDR[1,PDQ]" SOURCE_FILE;
00500
00600 INTERNAL PROCEDURE WAIT(INTEGER SECS);CALL(SECS,"SLEEP");
00700
00800 INTEGER FOO;
00850 DEFINE CR="'15",LF="'12",TAB="'11",SPACE="'40",CRLF="CR&LF";
00900
01000 INTEGER DATE,TIME;
01100 DEFINE GETIME="BEGIN DATE←CALL(0,""DATE""); TIME←CALL(0,""TIMER"")%60; END";
01200
01300 INTERNAL STRING PROCEDURE DATIM; ⊃ Returns string equivalent to monitor DAYTIME command;
01400 BEGIN INTEGER DAY,YR,HRS,MIN,SEC;
01500 PRELOAD_WITH "JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG",
01600 "SEP","OCT","NOV","DEC";
01700 OWN STRING_ARRAY MONTHS[0:11];
01800 DAY←(DATE MOD 31)+1;DATE←DATE%31;
01900 YR←1964+DATE%12;SEC←TIME MOD 60;TIME←TIME%60;MIN←TIME MOD 60;HRS←TIME%60;
02000 SETFORMAT(-2,0);
02100 RETURN(CVS(DAY)&"-"&MONTHS[DATE MOD 12]&"-"&CVS(YR)&" "&CVS(HRS)&CVS(MIN)&":"&CVS(SEC));
02200 END "DATIM";
02210
02220 INTERNAL REAL PROCEDURE RUNTIM;RETURN(CALL(0,"RUNTIM"));
02230 INTERNAL REAL PROCEDURE ALLTIM;RETURN(CALL(0,"TIMER")/60);
02235 INTERNAL REAL RTIM,ATIM;
02240 INTERNAL PROCEDURE TIMSET;BEGIN RTIM←RUNTIM;ATIM←ALLTIM;END;
02250 INTERNAL PROCEDURE TIMOUT(STRING S);
02255 BEGIN REAL DRT;SETFORMAT(5,2);
02257 OUTSTR(S&" SECS RUN="&CVF(DRT←RUNTIM-RTIM)&
02260 " % PROCESSOR="&CVF(100*DRT/(ALLTIM-ATIM))&CRLF);
02280 END;
02300
02400 INTERNAL STRING PROCEDURE DATIME;BEGIN GETIME;RETURN(DATIM);END;
02500
02600 INTERNAL PROCEDURE ERP(STRING S);USERERR(0,1,S); ⊃ Output error message S;
02700
02800 INTERNAL INTEGER PROCEDURE LOC(INTEGER X);RETURN(X);
02900 ⊃ When combined with the declaration:
03000 EXTERNAL INTEGER PROCEDURE LOC(REFERENCE INTEGER X)
03100 this procedure gives the address of X;
03200
03300 INTERNAL INTEGER PROCEDURE MIN(INTEGER X,Y);RETURN(IF X<Y THEN X ELSE Y);
03400 INTERNAL INTEGER PROCEDURE MAX(INTEGER X,Y);RETURN(IF X>Y THEN X ELSE Y);
03500
00100 ⊃ ********* Super good TTY I/O functions ********;
00200
00400
00500 INTERNAL PROCEDURE REALOUT(STRING S;REAL X);
00600 ⊃ outputs a real number on the TTY;
00700 BEGIN SETFORMAT(7,2);
00800 OUTSTR(S);
00900 OUTSTR((IF ABS(X)<1@-2 THEN CVE(X) ELSE CVF(X))&" ");
01000 END;
01100
01200 INTERNAL STRING PROCEDURE CVS3(INTEGER I);BEGIN SETFORMAT(3,0);RETURN(CVS(I)) END;
01300
01400 INTERNAL REAL PROCEDURE CVR(STRING S);RETURN(REALSCAN(S,FOO));
01500 ⊃ converts a real number to a string;
01600
01700 INTERNAL STRING PARS;
01800 INTERNAL BOOLEAN REMEMBER;
01900
02000 INTERNAL STRING PROCEDURE STRIN(STRING S);
02100 ⊃ prints S and returns a string input from the TTY. PARS remembers
02200 everything output and input if REMEMBER=TRUE;
02300 BEGIN STRING C;OUTSTR(S);SETBREAK(1,LF&TAB&SPACE,CR,"INS");
02400 C←TTYINL(1,FOO); IF REMEMBER THEN PARS←PARS&S&C&",";RETURN(C) END;
02500
02600 INTERNAL REAL PROCEDURE INREAL(STRING S);RETURN(CVR(STRIN(S)));
02700 ⊃ inputs a real number, remembering with PARS;
02800
02900 INTERNAL INTEGER PROCEDURE ININT(STRING S);RETURN(CVD(STRIN(S)));
03000 ⊃ Inputs an integer, remembering with PARS;
03100
00100 ⊃ ********* Array manipulation functions ********** cheat cheat;
00200
00300 ⊃ These functions allow one to cheat the SAIL block structure control
00400 of arrays without resorting to LEAP array datums. Arrays
00500 manipulated by these functions are referred to by an integer which is
00600 the address of the first word in the array. Subscripting must be done
00700 with byte operators and XPOINT or the equivalent;
00800
00900 INTERNAL INTEGER PROCEDURE ARRMAK(INTEGER SIZE);
01000 ⊃ Creates an array with SIZE words, and returns the address of the
01100 first word;
01200 START_CODE
01300 DEFINE P="'17";
01400 EXTERNAL INTEGER LRMAK;
01500 HRRZ 1,-1(P);PUSH P,[1];PUSH P,1;PUSH P,[1];
01600 PUSHJ P,LRMAK;
01700 END "ARRMAK";
01800
01900 INTERNAL PROCEDURE ARRYEL(INTEGER ADR);
02000 ⊃ Releases the array starting at location ADR;
02100 START_CODE
02200 DEFINE P="'17";
02300 EXTERNAL INTEGER ARYEL;
02400 HRRZS -1(P);
02500 SKIPE -1(P);
02600 JRST ARYEL;
02700 END "ARRYEL";
02800
02900 INTERNAL PROCEDURE PICREL(PICTURE PIC);
03000 ⊃ releases the array used for picture PIC and zeros the PTR parameter;
03100 BEGIN ARRYEL(PIC[PTR]);PIC[PTR]←0; END;
03200
03300 INTERNAL INTEGER PROCEDURE PICMAK(PICTURE PIC);
03400 ⊃ Determines the size array needed for picture PIC, allocates an array,
03500 and sets and returns the appropriate PTR parameter;
03600 BEGIN IF PIC[PTR] THEN PICREL(PIC);
03700 RETURN(PIC[PTR]←XPOINT(PIC[BIT],"ARRMAK(PIC[SIZEL]*PIC[SIZEY])",-1));
03800 END "PICMAK";
00100 ⊃ ******** Second segment functions *********;
00200 DEFINE CALLI="'47000000000",SEGNM2="'400036",CORE2="'400015",ATTSEG="'400016",DETSEG="'400017",HALT="JRST 4,";
00300 INTEGER SAINAM;
00400
00500 INTERNAL PROCEDURE ATOSEG(INTEGER SEGNAM,ADR,SEGADR);
00600 ⊃ Transfers the array starting at location ADR to the 2nd segment SEGNAM
00700 starting at 2nd segment address SEGADR;
00800 BEGIN SAINAM←CALL(0,"SEGNAM");
00900 START_CODE "GULP"
01000 CALLI DETSEG;
01100 MOVE 1,SEGNAM;CALLI 1,ATTSEG;JFCL;
01200 MOVE 1,ADR;HRRZ 2,-1(1); ⊃ SIZE;
01300 ADD 2,SEGADR;SUBI 2,1; ⊃ Last second segment address;
01400 MOVE 1,2;CALLI 1,CORE2;HALT;
01500 MOVS 1,ADR;HRR 1,SEGADR;BLT 1,(2);
01600 MOVE 1,SEGNAM;CALLI 1,SEGNM2;HALT;
01700 CALLI DETSEG;
01800 MOVE 1,SAINAM;CALLI 1,ATTSEG;HALT;
01900 END;
02000 END "ATOSEG";
02100
02200 INTERNAL PROCEDURE SEGTOA(INTEGER SEGNAM,ADR,SEGADR);
02300 ⊃ Transfers the contents of the 2nd segment named SEGNAM starting at
02400 location SEGADR to the array starting at location ADR;
02500 BEGIN SAINAM←CALL(0,"SEGNAM");
02600 START_CODE "GULP"
02700 CALLI DETSEG;
02800 MOVE 1,SEGNAM;CALLI 1,ATTSEG;HALT;
02900 MOVE 1,ADR;HRRZ 2,-1(1); ⊃ SIZE;
03000 ADDI 2,-1(1); ⊃ LSTADR;
03100 HRL 1,SEGADR;BLT 1,(2);
03200 CALLI DETSEG;
03300 MOVE 1,SAINAM;CALLI 1,ATTSEG;HALT;
03400 END;
03500 END "SEGTOA";
03600
03700 INTERNAL PROCEDURE KILSEG(INTEGER SEGNAM);
03800 ⊃ Kills 2nd segment SEGNAM;
03900 BEGIN SAINAM←CALL(0,"SEGNAM");
04000 START_CODE
04100 CALLI DETSEG;MOVE 1,SEGNAM;CALLI 1,ATTSEG;HALT;
04200 MOVEI 1,0;CALLI 1,CORE2;HALT;
04300 MOVE 1,SAINAM;CALLI 1,ATTSEG;HALT;
04400 END;
04500 END "KILSEG";
00100 ⊃ ********* The mailman ***********;
00200 ⊃ rain, sleet, hail, strikes, ... except SAT,SUN, holidays, ...;
00300 DEFINE MAIL="'710000000000";
00400
00500 INTERNAL BOOLEAN PROCEDURE SNDMAIL(INTEGER_ARRAY A;INTEGER DEST);
00600 ⊃ Sends contents of array A to mailbox of job DEST. Returns false if
00700 mail cannot be delivered;
00800 BEGIN INTEGER A1,A2; LABEL LOSE;
00900 A1←DEST;A2←POINT(0,A[1],35);
01000 START_CODE "GULP"
01100 MAIL A1;
01200 JRST LOSE;
01300 END;
01400 RETURN(TRUE);
01500 LOSE: RETURN(FALSE);
01600 END "SNDMAIL";
01700
01800 INTERNAL BOOLEAN PROCEDURE CANMAIL(INTEGER DEST);
01900 ⊃ Returns true if mail can be sent to job DEST, false otherwise;
02000 BEGIN INTEGER A;
02100 LABEL WIN;
02200 A←DEST;
02300 START_CODE "GULP"
02400 MAIL 4,A;
02500 JRST WIN;
02600 END;
02700 RETURN(FALSE);
02800 WIN: RETURN(TRUE);
02900 END "CANMAIL";
03000
03100 INTERNAL PROCEDURE UNSTR(STRING S;INTEGER PT,N);
03200 ⊃ Copies STRING a character at a time to where byte pointer PT
03300 specifies. At most N characters are transfered;
03400 WHILE S∧((N←N-1)≥0) DO IDPB(LOP(S),PT);
03500
03600 INTERNAL BOOLEAN PROCEDURE HAVEMAIL;
03700 ⊃ Returns TRUE if there is mail waiting;
03800 BEGIN LABEL LOSE;
03900 START_CODE
04000 MAIL 3,;
04100 JRST LOSE;
04200 END;
04300 RETURN(TRUE);
04400 LOSE: RETURN(FALSE);
04500 END "HAVEMAIL";
04600
04700 INTERNAL PROCEDURE RECMAIL(INTEGER_ARRAY A);
04800 ⊃ Receives mail in array A;
04900 START_CODE "GULP"
05000 MAIL 1,⊗A;
05100 END "RECMAIL";
05200
05300 INTERNAL STRING PROCEDURE MKSTR(INTEGER_ARRAY A;INTEGER I);
05400 ⊃ Constructs a string 5 characters at a time starting at A[I];
05500 BEGIN STRING S; S←NULL;
05600 WHILE (I<33)∧A[I] DO
05700 BEGIN S←S&CVSTR(A[I]);I←I+1;END;
05800 RETURN(S);
05900 END "MKSTR";
06000
00100 ⊃ The glorious pseudo pseudo quasi teletype functions;
00200
00300 DEFINE PTYUUO="'711000000000";
00400
00500
00600 INTERNAL PROCEDURE PTYOUT(INTEGER PTYNO;STRING S);
00700 BEGIN INTEGER_ARRAY PSTR[0:20];
00800 INTEGER PT,FOO,FOO2,C;
00900 FOO←PTYNO;FOO2←POINT(0,PSTR[0],35);
01000 PT←POINT(9,PSTR[0],-1);
01100 WHILE S DO IDPB(IF (C←LOP(S))="β" THEN '600 ELSE C,PT);
01200 IDPB(0,PT);
01300 START_CODE PTYUUO '12,FOO;END;
01400 END "PTYOUT";
01500
01600 INTEGER PROCEDURE JBTLIN(INTEGER JOBNO);
01700 ⊃ Returns the teletype number attached to job JOBNO;
01800 BEGIN INTEGER BASE;
01900 BASE←CALL('236,"PEEK");
02000 RETURN(CALL(BASE+JOBNO,"PEEK"));
02100 END;
02200
02300 INTEGER PTYNO;
02400 PROCEDURE SUCK(STRING S);PTYSTR(PTYNO,S);
02500 ⊃ Inputs from PTY up to the character S;
02600
02700 PROCEDURE MAKEJOB(STRING COMMAND,PPN);
02800 ⊃ Sets up a PTY, logs in a job under project-programmer name PPN,
02900 executes command string COMMAND, detaches the job and releases the PTY;
03000 BEGIN
03100 PTYNO←PTYGET;
03200 PTOSTR(PTYNO,"L"&CRLF);SUCK("#");
03300 PTOSTR(PTYNO,PPN&CRLF);SUCK(".");
03400 PTOSTR(PTYNO,COMMAND&CRLF);SUCK("→");
03500 WAIT(1);PTOSTR(PTYNO,"ββCCONT"&CRLF&CRLF);SUCK("T");SUCK(".");
03600 PTOSTR(PTYNO,"DET"&CRLF&CRLF);PTYALL(PTYNO);WAIT(1);PTYALL(PTYNO);
03700 OUTSTR(COMMAND&" EXECUTED"&CRLF);
03800 PTYREL(PTYNO);
03900 END "MAKEJOB";
04000
04100
04200 INTERNAL PROCEDURE WAITJOB(INTEGER_ARRAY MESS);
04300 ⊃ Waits for mail, which signals that another job is finished, and is
04400 returning control;
04500 BEGIN RECMAIL(MESS);
04600 WAIT(0);
04700 PTYOUT(0,"ββCONT"&CRLF);
04800 END "WAITJOB";
04900
05000 INTERNAL INTEGER PROCEDURE JOBNUMBER(STRING JOBNAM);
05100 ⊃ returns the job number associated with job name JOBNAM. If JOBNAM
05200 does not exist, 0 is returned;
05300 BEGIN INTEGER NAM,J,BASE,JMAX;
05400 LABEL L;
05500 NAM←CVSIX(JOBNAM);
05600 JMAX←CALL('222,"PEEK");
05700 BASE←CALL('225,"PEEK");
05800 FOR J←1 STEP 1 UNTIL JMAX DO
05900 IF CALL(BASE+J,"PEEK")=NAM THEN GO TO L;
06000 RETURN(0);
06100 L: RETURN(J);
06200 END "JOBNUMBER";
06300
06400 INTERNAL INTEGER PROCEDURE MYPRGNAM;
06500 ⊃ returns the job number associated with this job;
06600 BEGIN INTEGER BASE;BASE←CALL('225,"PEEK");
06700 RETURN(CALL(BASE+CALL(0,"PJOB"),"PEEK"));
06800 END;
06900
07000 INTERNAL BOOLEAN PROCEDURE STARTJOB(STRING JOBNAM,PPN;INTEGER_ARRAY MESS);
07100
07200 ⊃ This procedure "calls" another job JOBNAM as a subroutine. The job
07300 is logged in and started if necessary. The present job is
07400 ↑Ced,CCONTed, and the desired job is ATTached. The present job then
07500 sends array MESS through mail to the called job;
07600
07700 BEGIN INTEGER ARRAY FOO[1:32];INTEGER JOBNO;
07800 WHILE (JOBNO←JOBNUMBER(JOBNAM))=0 DO MAKEJOB("RU "&JOBNAM,PPN); ⊃ log in the job if necessary;
07900 WHILE JBTLIN(JOBNO)≠-1 DO
08000 IF STRIN(JOBNAM&" BUSY, WANT TO WAIT?")≠"Y" THEN RETURN(FALSE);⊃ the other job must be detached;
08100 PTYOUT(0,"ββCCONT"&CRLF);
08200 WAIT(0);
08300 PTYOUT(0,"ATT "&CVS(JOBNO)&CRLF); ⊃ attach the other job;
08400 WHILE HAVEMAIL DO RECMAIL(FOO); ⊃ empty my mail box;
08500 WHILE ¬SNDMAIL(MESS,JOBNO) DO ; ⊃ send MESS to JOBNO until it is received;
08600 RETURN(TRUE);
08700 END "STARTJOB";
08800
08900 END "COMSUB";
00100 REQUIRE "COMSUB.SAI" LOAD_MODULE;
00200 EXTERNAL INTEGER PROCEDURE ARRMAK(INTEGER SIZE);
00300 EXTERNAL INTEGER PROCEDURE PICMAK(PICTURE PIC);
00400 EXTERNAL PROCEDURE ARRYEL(INTEGER ADR);
00500 EXTERNAL PROCEDURE PICREL(PICTURE PIC);
00600 EXTERNAL PROCEDURE WAIT(INTEGER SECS);
00700
00800 EXTERNAL STRING PROCEDURE DATIM; ⊃ Returns string equivalent to monitor DAYTIME command;
00900 EXTERNAL STRING PROCEDURE DATIME;
01000
01100 EXTERNAL STRING PROCEDURE STRIN(STRING S);
01200 ⊃ ********* Super good TTY I/O functions ********;
01300
01400 DEFINE CR="'15",LF="'12",TAB="'11",SPACE="'40",CRLF="CR&LF";
01500
01600 EXTERNAL PROCEDURE REALOUT(STRING S;REAL X);
01700 EXTERNAL STRING PROCEDURE CVS3(INTEGER I);
01800 EXTERNAL REAL PROCEDURE CVR(STRING S);
01900 EXTERNAL REAL PROCEDURE INREAL(STRING S);
02000 EXTERNAL INTEGER PROCEDURE ININT(STRING S);
02100
02200 ⊃ ********** Second segment stuff -- be careful ********;
02300 EXTERNAL INTEGER PROCEDURE ATOSEG(INTEGER SEGNAM,ADR,SEGADR);
02400 EXTERNAL PROCEDURE SEGTOA(INTEGER SEGNAM,ADR,SEGADR);
02500 EXTERNAL PROCEDURE KILSEG(INTEGER SEGNAM);
02600
02700 ⊃ ********** Mailman -- rain, sleet, snow, (except holidays, Sat and Sun);
02800 EXTERNAL BOOLEAN PROCEDURE SNDMAIL(INTEGER_ARRAY MAILBOX;INTEGER DEST);
02900 EXTERNAL BOOLEAN PROCEDURE CANMAIL(INTEGER DEST);
03000 EXTERNAL PROCEDURE UNSTR(STRING S;INTEGER PT,N);
03100 EXTERNAL PROCEDURE RECMAIL(INTEGER_ARRAY A);
03200 EXTERNAL BOOLEAN PROCEDURE HAVEMAIL;
03300 EXTERNAL STRING PROCEDURE MKSTR(INTEGER_ARRAY A;INTEGER I);
03400 EXTERNAL BOOLEAN PROCEDURE STARTJOB(INTEGER JOBNO;INTEGER_ARRAY MESS);
03500 EXTERNAL INTEGER PROCEDURE MYPRGNAM;
03600 EXTERNAL PROCEDURE WAITJOB(INTEGER_ARRAY MESS);
03700 EXTERNAL INTEGER PROCEDURE JOBNUMBER(STRING JOBNAM);
03800